Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume10/comobj.lisp/part10

Text File | 1987-08-02 | 36.0 KB | 888 lines

Path: uunet!rs
From: [e-mail] (Rich Salz)
Newsgroups: comp.sources.unix
Subject: v10i084:  Common Objects, Common Loops, Common Lisp, Part10/13
Message-ID: <[e-mail]>
Date: 3 Aug 87 21:17:56 GMT
Organization: UUNET Communications Services, Arlington, VA
Lines: 877
Approved: [e-mail]

Submitted-by: Roy D'Souza <[e-mail]>
Posting-number: Volume 10, Issue 84
Archive-name: comobj.lisp/Part10

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 10 (of 13)."
# Contents:  braid.l
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'braid.l' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'braid.l'\"
else
echo shar: Extracting \"'braid.l'\" \(34250 characters\)
sed "s/^X//" >'braid.l' <<'END_OF_FILE'
X;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
X;;;
X;;; *************************************************************************
X;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
X;;;
X;;; Use and copying of this software and preparation of derivative works
X;;; based upon this software are permitted.  Any distribution of this
X;;; software or derivative works must comply with all applicable United
X;;; States export control laws.
X;;;
X;;; This software is made available AS IS, and Xerox Corporation makes no
X;;; warranty about the software, its performance or its conformity to any
X;;; specification.
X;;;
X;;; Any person obtaining a copy of this software is requested to send their
X;;; name and post office or electronic mail address to:
X;;;   CommonLoops Coordinator
X;;;   Xerox Artifical Intelligence Systems
X;;;   2400 Hanover St.
X;;;   Palo Alto, CA 94303
X;;; (or send Arpanet mail to [e-mail])
X;;;
X;;; Suggestions, comments and requests for improvements are also welcome.
X;;; *************************************************************************
X;;;
X;;; The meta-braid and defstruct.
X;;;
X;;; NOTE: This file must be loaded before it can be compiled.
X
X#| *** TO DO ***
X
X|#
X(in-package 'pcl)
X
X  ;;
X;;;;;; Medium-level support for the class CLASS.
X  ;;
X;;; The low-level macros are defined by the file portable-low (or a special
X;;; version) of that file if there is one for this implementation.  This is
X;;; the lowest-level completely portable code which operates on instances
X;;; with meta-class class.
X
X(defmacro get-static-slot--class (iwmc-class slot-index)
X  `(%static-slot-storage-get-slot--class
X     (iwmc-class-static-slots ,iwmc-class)
X     ,slot-index))
X
X(defmacro get-dynamic-slot--class (iwmc-class slot-name default)
X  `(%dynamic-slot-storage-get-slot--class
X     (iwmc-class-dynamic-slots ,iwmc-class)
X     ,slot-name
X     ,default))
X
X(defmacro remove-dynamic-slot--class (iwmc-class slot-name)
X  `(%dynamic-slot-storage-remove-slot--class
X     (iwmc-class-dynamic-slots ,iwmc-class)
X     ,slot-name))
X
X
X  ;;
X;;;;;; defmeth  -- defining methods
X  ;;
X;;; We need to be able to define something like methods before we really have
X;;; real method functionality available.
X;;;
X;;; defmeth expands by calling expand-defmeth, this means that we can define
X;;; an early version of defmeth just by defining an early version of expand-
X;;; defmeth.
X;;;
X(defmacro defmethod (&rest args)
X ;(declare (zl:arglist name qualifier* arglist &body body))
X  (let ((name (pop args))
X    (qualifiers ())
X    (arglist ())
X    (body nil))
X    (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
X    (setq arglist (pop args)
X      body args)
X    `(defmeth (,name . ,qualifiers) ,arglist . ,body)))
X
X(defmacro defmethod-setf (&rest args)
X  (let ((name (pop args))
X    (qualifiers ())
X    (arglist ())
X    (new-value-arglist ())
X    (body nil))
X    (multiple-value-setq (qualifiers args) (defmethod-qualifiers args))
X    (setq arglist (pop args)
X      new-value-arglist (pop args)
X      body args)
X    `(defmeth (,name (:setf ,new-value-arglist) ,.qualifiers) ,arglist
X       ,@body)))
X
X(defun defmethod-qualifiers (args)
X  (declare (values qualifiers arglist-and-body))
X  (let ((qualifiers ()))
X    (loop (if (and (car args) (listp (car args)))
X          (return (values (nreverse qualifiers) args))
X          (push (pop args) qualifiers)))))
X
X(defun defmethod-argument-specializers (arglist)
X  (let ((arg (car arglist)))
X    (cond ((null arglist) nil)
X      ((memq arg '(&optional &rest &key &aux)) nil) ;Don't allow any
X                                                        ;argument specializers
X                                                    ;after one of these.
X      ((memq arg lambda-list-keywords)            ;Or one of these!!
X       (warn "Unrecognized lambda-list keyword ~S in arglist.~%~
X                  Assuming that no argument specializers appear after it."
X         arg)
X       nil)
X      (t
X       (let ((tail (defmethod-argument-specializers (cdr arglist)))
X         (specializer (and (listp arg) (cadr arg))))
X         (or (and tail (cons (or specializer 't) tail))
X         (and specializer (cons specializer ()))))))))
X
X
X(defmacro defmeth (name&options arglist &body body)
X  (expand-defmeth name&options arglist body))
X
X(eval-when (compile load eval)
X  ;; Make sure we call bootstrap-expand-defmeth during bootstrapping.
X  ;;  - Can't say (setf (symbol-fu ..) #'bootstrap-expand-defmeth because
X  ;;    bootstrap-expand-defmeth isn't defined yet and that isn't legal
X  ;;    in Common Lisp.
X  ;;  - Can't say (setf (symbol-fu ..) 'bootstrap-expand-defmeth because
X  ;;    not all Common Lisps like having symbols in the function cell.
X  (setf (symbol-function 'expand-defmeth)
X    #'(lambda (name&options arglist body)
X        (bootstrap-expand-defmeth name&options arglist body)))
X  )
X
X  ;;
X;;;;;; Early methods
X  ;;
X
X(defvar *real-methods-exist-p*)
X(eval-when (compile load eval)
X  (setq *real-methods-exist-p* nil))
X
X(eval-when (load)
X  (setq *error-when-defining-method-on-existing-function* 'bootstrapping))
X
X(defvar *protected-early-selectors* '(print-instance))
X
X(defparameter *early-defmeths* ())
X
X(defmacro simple-type-specs (arglist)
X  `(let ((type-specs
X       (iterate ((arg in ,arglist))
X            (until (memq arg '(&optional &rest &key &aux)))
X            (collect (if (listp arg) (cadr arg) 't)))))
X     (setq type-specs (nreverse type-specs))
X     (iterate ((type-spec in type-specs))
X          (until (neq type-spec 't))
X          (pop type-specs))
X     (nreverse type-specs)))
X
X(defmacro simple-without-type-specs (arglist)
X  `(iterate ((loc on ,arglist))
X        (cond ((memq (car loc) '(&optional &rest &key &aux))
X           (join loc) (until t))
X          (t
X           (collect (if (listp (car loc))
X                (caar loc)
X                (car loc)))))))
X(defmacro simple-args (arglist)
X  `(iterate ((arg in ,arglist))
X        (until (eq arg '&aux))
X        (unless (memq arg '(&optional &rest &key))
X          (collect (if (listp arg) (car arg) arg)))))
X
X(defun bootstrap-expand-defmeth (name&options arglist body)
X  ;; Some SIMPLE local macros for getting the type-specifiers out of the
X  ;; argument list.  Unfortunately, it is important that these simple
X  ;; macros and the methods which come along later and do this job better
X  ;; be compatible.  This will become less of an issue once methods don't
X  ;; have names anymore.
X; (macrolet ()
X    (multiple-value-bind (documentation declares body)
X        (extract-declarations body)
X      (or (listp name&options) (setq name&options (list name&options)))
X      (keyword-parse ((setf () setfp))
X                     (cdr name&options)
X        (let* ((name (car name&options))
X               (discriminator-name (if setfp
X                       (make-setf-discriminator-name name)
X                       name))
X               (method-name (if setfp
X                                (make-setf-method-name
X                  name
X                  (simple-type-specs setf)
X                  (simple-type-specs arglist))
X                                (make-method-name
X                  name (simple-type-specs arglist))))
X               (method-arglist (simple-without-type-specs
X                                 (if setfp
X                                     (cons (car arglist)
X                       (append setf (cdr arglist)))
X                                     arglist))))
X          `(progn
X             ;; Record this early defmeth so that fixup-early-defmeths will
X             ;; know to fix it up later.
X             (eval-when (compile load eval)
X               (record-early-defmeth
X         ',discriminator-name ',name&options ',arglist ',body))
X         (record-definition ',discriminator-name 'method)
X             (defun ,method-name ,method-arglist
X               ,@(and documentation (list documentation))
X               ,@declares
X;              #+Symbolics(declare (sys:function-parent ,name defmeth))
X               . ,body)
X         ,(unless (memq discriminator-name *protected-early-selectors*)
X        `(eval-when (load eval)
X           (setf (symbol-function ',discriminator-name)
X             (symbol-function ',method-name))))
X             ,@(and setfp
X            (not (memq discriminator-name *protected-early-selectors*))
X                    (let ((args (simple-without-type-specs arglist))
X                          (setf-args (simple-without-type-specs setf)))
X                      `((defsetf ,name ,args ,setf-args
X                          (list ',discriminator-name
X                                ,(car args)
X                                ,@(simple-args setf)
X                                ,@(simple-args (cdr args))))))))))))
X;)
X
X(defun record-early-defmeth (discriminator-name name&options arglist body)
X  (pushnew (list* 'defmeth discriminator-name name&options arglist body)
X       *early-defmeths*
X       :test #'equal))
X
X(defun record-early-discriminator (discriminator-name)
X  (pushnew (list 'clear discriminator-name) *early-defmeths* :test #'equal))
X
X(defun record-early-method-fixup (form)
X  (pushnew (list 'eval form) *early-defmeths* :test #'equal))
X
X(defmacro fix-early-defmeths ()
X  (let ((resets ())
X    (evals ()))
X    (dolist (entry *early-defmeths*)
X      (ecase (car entry)
X    (defmeth (push (cons 'defmeth (cddr entry)) evals)
X         (push (cadr entry) resets))
X    (clear   (push (cadr entry) resets))
X    (eval    (push (cadr entry) evals))))
X    `(progn
X       ;; The first thing to do is go through and get rid of all the old
X       ;; discriminators.  This only needs to happen when we are being
X       ;; loaded into the same VMem we were compiled in.  The WHEN is
X       ;; making that optimization.
X       (defun fix-early-defmeths-1 ()
X     (when (discriminator-named ',(car resets))
X       (dolist (x ',resets) (setf (discriminator-named x) nil))))
X       (fix-early-defmeths-1)
X       ,@evals)))
X
X#| This is useful for debugging.
X(defmacro unfix-early-defmeths ()
X  `(progn
X     (do-symbols (x)
X       (remprop x 'discriminator)
X       (remprop x 'setf-discriminator))
X     . ,(mapcar '(lambda (x) (cons 'defmeth x)) (reverse *early-defmeths*))))
X
X(unfix-early-defmeths)
X|#
X
X(defun make-setf-discriminator-name (name)
X  (intern (string-append name " :SETF-discriminator")
X      (symbol-package name)))
X
X(defun make-method-name (selector type-specifiers)
X  (intern (apply #'string-append
X                      (list* "Method "
X                             selector
X                             " "
X                             (make-method-name-internal type-specifiers)))
X      (symbol-package selector)))
X
X(defun make-setf-method-name (selector setf-type-specifiers type-specifiers)
X  (intern (apply #'string-append
X                      (list* "Method "
X                             selector
X                             " ("
X                             (apply #'string-append
X                                    ":SETF "
X                                    (make-method-name-internal setf-type-specifiers))
X                             ") "
X                             (make-method-name-internal type-specifiers)))
X      (symbol-package selector)))
X
X(defun make-method-name-internal (type-specifiers)
X  (if type-specifiers
X      (iterate ((type-spec on type-specifiers))
X        (collect (string (car type-spec)))
X        (when (cdr type-spec) (collect " ")))
X      '("Default")))
X
X
X
X  ;;
X;;;;;; SLOTDS and DS-OPTIONS
X  ;;
X;;;
X;;; A slot-description is the thing which appears in a defstruct.  A SLOTD is
X;;; an internal description of a slot.
X;;;
X;;; The SLOTD structure corresponds to the kind of slot the structure-class
X;;; meta-class creates (the kind of slot that appears in Steele Edition 1).
X;;; Other metaclasses which need to have more elaborate slot options and
X;;; slotds, they :include that class in their slotds.
X;;;
X;;; slotds are :type list for 2 important reasons:
X;;;   - so that looking up a slotd in a list of lists will compile
X;;;     into a call to assq
X;;;   - PCL assumes only the existence of the simplest of defstructs
X;;;     this allows PCL to be used to implement a real defstruct.
X;;;
X(defstruct (essential-slotd (:type list)
X                (:constructor make-slotd--essential-class))
X  name)
X
X;;;
X;;; Slotd-position is used to find the position of a slot with a particular
X;;; name in a list of slotds.  Specifically it is used in the case of a
X;;; get-slot cache miss to find this slot index.  That means it is used in
X;;; about 2% of the total slot accesses so it should be fast.
X;;;
X(defmacro slotd-position (slotd-name slotds)
X  `(let ((slotd-name ,slotd-name))
X     (do ((pos 0 (+ pos 1))
X      (slotds ,slotds (cdr slotds)))
X     ((null slotds) nil)
X       (declare (type integer pos) (type list slotds))
X       (and (eq slotd-name (slotd-name (car slotds)))
X        (return pos)))))
X
X(defmacro slotd-member (slotd-name slotds)                  ;I wonder how
X  `(member ,slotd-name ,slotds :test #'eq :key #'slotd-name)) ;many compilers
X                                      ;are really
X                                      ;smart enough.
X(defmacro slotd-assoc (slotd-name slotds)
X  `(assq ,slotd-name ,slotds))
X
X;;;
X;;; Once defstruct-options are defaulted and parsed, they are stored in a
X;;; ds-options (defstruct-options) structure.  This modularity makes it
X;;; easier to build the meta-braid which has to do some slot and option
X;;; parsing long before the real new defstruct exists.  More importantly,
X;;; this allows new meta-classes to inherit the option parsing code
X;;; from other metaclasses.
X;;;
X(defstruct (ds-options (:constructor make-ds-options--class))
X  name
X  constructors             ;The constructor argument, a list whose car is the
X               ;name of the constructor and whose cadr if present
X                           ;is the argument-list for the constructor.
X  copier                   ;(defaulted) value of the :copier option.
X  predicate                ;ditto for :predicate
X  print-function           ;ditto for :print-function
X  generate-accessors       ;ditto for :generate-accessors
X  conc-name                ;ditto for :conc-name
X  includes                 ;The included structures (car of :include)
X  slot-includes            ;The included slot modifications (cdr of :include)
X  initial-offset           ;(defaulted) value of the :initial-offset option.
X  )
X
X
X
X  ;;
X;;;;;; The beginnings of the meta-class CLASS (parsing the defstruct)
X  ;;
X
X(defmeth make-ds-options ((class basic-class) name)
X  (ignore class)
X  (make-ds-options--class :name name))
X
X(defmeth parse-defstruct-options ((class basic-class) name options)
X  (parse-defstruct-options-internal
X    class name options
X    (default-ds-options class name (make-ds-options class name))))
X
X(defmeth default-ds-options ((class basic-class) name ds-options)
X  (ignore class)
X  (setf
X    (ds-options-constructors ds-options)       `((,(symbol-append "MAKE-"
X                                  name)))
X    (ds-options-copier ds-options)             (symbol-append "COPY-" name)
X    (ds-options-predicate ds-options)          (symbol-append name "-P")
X    (ds-options-print-function ds-options)     nil
X    (ds-options-generate-accessors ds-options) 'method
X    (ds-options-conc-name ds-options)          (symbol-append name "-")
X    (ds-options-includes ds-options)           ()
X    (ds-options-slot-includes ds-options)      ()
X    (ds-options-initial-offset ds-options)     0)
X  ds-options)
X
X(defmeth parse-defstruct-options-internal ((class basic-class)
X                        name options ds-options)
X  (ignore class name)
X  (keyword-parse ((conc-name (ds-options-conc-name ds-options))
X                  (constructor () constructor-p :allowed :multiple
X                        :return-cdr t)
X                  (copier (ds-options-copier ds-options))
X                  (predicate (ds-options-predicate ds-options))
X                  (include () include-p :return-cdr t)
X                  (print-function () print-function-p)
X                  (initial-offset (ds-options-initial-offset ds-options))
X                  (generate-accessors (ds-options-generate-accessors
X                    ds-options)))
X                 options
X    (setf (ds-options-conc-name ds-options) conc-name)
X    (when constructor-p
X      (setf (ds-options-constructors ds-options) constructor))
X    (setf (ds-options-copier ds-options) copier)
X    (setf (ds-options-predicate ds-options) predicate)
X    (when include-p
X      (destructuring-bind (includes . slot-includes) include
X    (setf (ds-options-includes ds-options) (if (listp includes)
X                           includes
X                           (list includes))
X          (ds-options-slot-includes ds-options) slot-includes)))
X    (when print-function-p
X      (setf (ds-options-print-function ds-options)
X        (cond ((null print-function) nil)
X          ((symbolp print-function) print-function)
X          ((and (listp print-function)
X            (eq (car print-function) 'lambda)
X            (listp (cadr print-function)))
X           print-function)
X          (t
X           (error "The :PRINT-FUNCTION option, ~S~%~
X                           is not either nil or a function suitable for the~
X                           function special form."
X               print-function)))))
X    (setf (ds-options-initial-offset ds-options) initial-offset)
X    (setf (ds-options-generate-accessors ds-options) generate-accessors)
X    ds-options))
X
X;;;
X;;;
X
X(defvar *slotd-unsupplied* (list nil))
X
X(defstruct (class-slotd (:include essential-slotd)
X            (:type list)
X            (:conc-name slotd-)
X            (:constructor make-slotd--class)
X            (:copier copy-slotd))
X  keyword
X  (default *slotd-unsupplied*)
X  (type *slotd-unsupplied*)
X  (read-only *slotd-unsupplied*)
X  (accessor *slotd-unsupplied*)
X  (allocation *slotd-unsupplied*)
X  get-function   ;NIL if no :get(put)-function argument was supplied.
X  put-function   ;Otherwise, a function of two (three)arguments, the
X                 ;object, the name of the slot (and the new-value).
X  )
X
X(defmeth make-slotd ((class basic-class) &rest keywords-and-options)
X  (ignore class)
X  (apply #'make-slotd--class keywords-and-options))
X
X(defmeth parse-slot-descriptions ((class basic-class) ds-options slot-descriptions)
X  (iterate ((slot-description in slot-descriptions))
X    (collect (parse-slot-description class ds-options slot-description))))
X
X(defmeth parse-slot-description ((class basic-class) ds-options slot-description)
X  (parse-slot-description-internal
X    class ds-options slot-description (make-slotd class)))
X
X(defmeth parse-slot-description-internal ((class basic-class) ds-options slot-description slotd)
X  (ignore class)
X  (let ((conc-name (ds-options-conc-name ds-options))
X        (generate-accessors (ds-options-generate-accessors ds-options)))
X    #+Lucid (declare (special conc-name generate-accessors))
X    (destructuring-bind (name default . args)
X                        slot-description
X      (keyword-bind ((type nil)
X                     (read-only nil)
X                     (generate-accessor generate-accessors)
X                     (allocation :instance)
X                     (get-function nil)
X                     (put-function nil)
X
X             (accessor nil accessor-p)
X             (initform nil)        ;ignore
X             )
X                    args
X        #+Lucid(declare (special type read-only generate-accessor allocation
X                                 get-function put-function))
X        (check-member allocation '(:class :instance :dynamic)
X                      :test #'eq
X                      :pretty-name "the :allocation option")
X        (setf (slotd-name slotd)         name
X              (slotd-keyword slotd)      (make-keyword name)
X              (slotd-default slotd)      default
X              (slotd-type slotd)         type
X              (slotd-read-only slotd)    read-only
X              (slotd-accessor slotd)     (if accessor-p
X                         accessor
X                         (and generate-accessor
X                          (if conc-name
X                             (symbol-append conc-name
X                                    name)
X                             name)))
X              (slotd-allocation slotd)   allocation
X              (slotd-get-function slotd) (and get-function
X                                              (if (and (consp get-function)
X                                                       (eq (car get-function) 'function))
X                                                  get-function
X                                                  (list 'function get-function)))
X              (slotd-put-function slotd) (and put-function
X                                              (if (and (consp put-function)
X                                                       (eq (car put-function) 'function))
X                                                  put-function
X                                                  (list 'function put-function))))
X        slotd))))
X
X;;;
X;;; Take two lists of slotds and return t if they describe an set of slots of
X;;; the same shape.  Otherwise return nil.  Sets of slots are have the same
X;;; same shape if they have they both have the same :allocation :instance
X;;; slots and if those slots appear in the same order.
X;;;
X(defun same-shape-slots-p (old-slotds new-slotds)
X  (do ()
X      ((and (null old-slotds) (null new-slotds)) t)
X    (let* ((old (pop old-slotds))
X       (new (pop new-slotds))
X       (old-allocation (and old (slotd-allocation old)))
X       (new-allocation (and new (slotd-allocation new))))
X      ;; For the old and new slotd check all the possible reasons
X      ;; why they might not match.
X      ;;   - One or the other is null means that a slot either
X      ;;     disappeared or got added.
X      ;;   - The names are different means that a slot moved
X      ;;     disappared or go added.
X      ;;   - If the allocations are different, and one of them
X      ;;     is :instance then a slot either became or ceased
X      ;;     to be :allocation :instance.
X      (when (or (null old)
X        (null new)
X        (neq (slotd-name old) (slotd-name new))
X        (and (neq old-allocation new-allocation)
X             (or (eq old-allocation :instance)
X             (eq new-allocation :instance))))
X    (return nil)))))
X
X(defmeth slots-with-allocation ((class basic-class) slotds allocation)
X  (ignore class)
X  (iterate ((slotd in slotds))
X    (when (eq (slotd-allocation slotd) allocation)
X      (collect slotd))))
X
X(defmeth slots-with-allocation-not ((class basic-class) slotds allocation)
X  (ignore class)
X  (iterate ((slotd in slotds))
X    (unless (eq (slotd-allocation slotd) allocation)
X      (collect slotd))))
X
X  ;;
X;;;;;; GET-SLOT and PUT-SLOT
X  ;;
X;;; Its still too early to fully define get-slot and put-slot since they need
X;;; the meta-braid to work.
X;;;
X;;; But its nice if as part of defining the meta-braid we can define and compile
X;;; code which does get-slots and setfs of get-slots and in order to do this we
X;;; need to have get-slot around.  Actually we could do with just the defsetf of
X;;; get-slot but might as well put all 3 here.
X;;;
X;;; The code bootstrap meta-braid defines with get-slot in it is all done with
X;;; defmeth, so these get-slots will all get recompiled once the optimizers
X;;; exist don't worry.
X(defun get-slot (object slot-name)
X  (get-slot-using-class (class-of object) object slot-name))
X
X(defun put-slot (object slot-name new-value)
X  (put-slot-using-class (class-of object) object slot-name new-value))
X
X(defun setf-of-get-slot (new-value object slot-name)
X  (put-slot-using-class (class-of object) object slot-name new-value))
X
X(defsetf get-slot (object slot-name &rest extra-args) (new-value)
X  `(setf-of-get-slot ,new-value ,object ,slot-name . ,extra-args))
X
X(defun get-slot-always (object slot-name &optional default)
X  (get-slot-using-class (class-of object) object slot-name t default))
X
X(defun put-slot-always (object slot-name new-value)
X  (put-slot-using-class (class-of object) object slot-name new-value t))
X
X(defsetf get-slot-always (object slot-name &optional default) (new-value)
X  `(put-slot-always ,object ,slot-name ,new-value))
X
X(defun remove-dynamic-slot (object slot-name)
X  (remove-dynamic-slot-using-class (class-of object) object slot-name))
X
X
X
X
X  ;;
X;;;;;; Actually bootstrapping the meta-braid
X  ;;
X;;;
X;;; *meta-braid* is the list from which the initial meta-classes are created.
X;;; The elements look sort of like defstructs.  The car of each element is
X;;; the name of the class;  the cadr is the defstruct options;  the caddr is
X;;; the slot-descriptions.
X;;;
X(defvar *meta-braid*
X        '((t
X            ((:include ()))
X            ())
X          (object
X            ((:include (t)))
X            ())
X          (essential-class
X            ((:include (object))
X             (:conc-name class-))
X            ((name nil)                    ;A symbol, the name of the class.
X             (class-precedence-list ())    ;The class's class-precedence-list
X                       ;see compute-class-precedence-list
X             (local-supers ())           ;This class's direct superclasses.
X         (local-slots ())
X             (direct-subclasses ())       ;All the classes which have this
X                       ;class on their local-supers.
X         (direct-methods ())
X         ))
X          (basic-class
X            ((:include (essential-class))
X         (:conc-name class-))
X            ((no-of-instance-slots 0)      ;The # of slots with :allocation :instance
X                                           ;in an instance of this class.
X             (instance-slots ())           ;The slotds of those slots.
X             (non-instance-slots ())       ;The declared slots with :allocation other
X                                           ;than :instance.  instance-slots + non-
X                                           ;instance-slots = all-slots.
X             (wrapper nil)                 ;The class-wrapper which instances of
X                                           ;this class point to.
X         (direct-discriminators ())
X         (discriminators-which-combine-methods ())
X             (prototype nil :get-function (lambda (c slot-name)
X                                            (ignore slot-name)
X                                            (or (get-slot c 'prototype)
X                                                (setf (get-slot c 'prototype)
X                                                      (make c)))))
X             (ds-options ())))
X      (class
X        ((:include (basic-class)))
X        ())))
X
X;;;
X;;; *bootstrap-slots* is a list of the slotds corresponding to the slots of class
X;;; class with :allocation :instance.  It is used by bootstrap-get-slot during the
X;;; bootstrapping of the meta-braid.
X;;;
X(defvar *bootstrap-slots*)
X
X(defmacro bootstrap-get-slot (iwmc-class slot-name)
X  `(get-static-slot--class ,iwmc-class
X        (%convert-slotd-position-to-slot-index
X          (slotd-position ,slot-name *bootstrap-slots*))))
X
X(defun bootstrap-initialize (iwmc-class name includes local-slots
X                                        prototype wrapper ds-options)
X  (let ((cpl ())
X        (all-slots ())
X        (instance-slots ()))
X    (setf (bootstrap-get-slot iwmc-class 'name) name)
X    (setf (bootstrap-get-slot iwmc-class 'local-supers)
X          (iterate ((i in includes)) (collect (class-named i))))
X    (setf (bootstrap-get-slot iwmc-class 'class-precedence-list)
X          (setq cpl (bootstrap-compute-class-precedence-list iwmc-class)))
X    (setq all-slots (append (iterate ((super in (reverse (cdr cpl))))
X                              (join (bootstrap-get-slot super 'local-slots)))
X                            local-slots))
X    (setf (bootstrap-get-slot iwmc-class 'instance-slots)
X          (setq instance-slots (slots-with-allocation () all-slots :instance)))
X    (setf (bootstrap-get-slot iwmc-class 'non-instance-slots)
X          (slots-with-allocation-not () all-slots :instance))
X    (setf (bootstrap-get-slot iwmc-class 'no-of-instance-slots)
X          (length instance-slots))
X    (setf (bootstrap-get-slot iwmc-class 'local-slots) local-slots)
X    (setf (bootstrap-get-slot iwmc-class 'direct-discriminators) ())
X    (setf (bootstrap-get-slot iwmc-class 'direct-methods) ())
X    (setf (bootstrap-get-slot iwmc-class 'prototype) prototype)
X    (setf (bootstrap-get-slot iwmc-class 'wrapper) wrapper)
X    (setf (bootstrap-get-slot iwmc-class 'ds-options) ds-options)))
X
X(defun bootstrap-compute-class-precedence-list (class)
X  ;; Used by define-meta-braid to compute the class-precedence-list of a class.
X  (let ((local-supers (bootstrap-get-slot class 'local-supers)))
X    (cons class
X          (and local-supers
X               (iterate ((ls in local-supers))
X                 (join (bootstrap-compute-class-precedence-list ls)))))))
X
X;;; bootstrap-meta-braid sets *bootstrap-slots* and builds the meta-braid.
X;;; Note that while it is somewhat general-purpose and driven off of *meta-braid*,
X;;; it has several important built-in assumptions about the meta-braid.
X;;; Namely:
X;;;  - The class of every class in the meta-braid is class.
X;;;  - The class class inherits its slots from every other class in the
X;;;    meta-braid.  Put another way, bootstrap-meta-braid figures out the
X;;;    slots of class by appending the slots of all the other classes
X;;;    in the meta-braid.
X;;;
X(defmacro bootstrap-meta-braid ()
X  ;; Parse *meta-braid* and setup *bootstrap-slots* so that we can call
X  ;; bootstrap-get-slot to fill in the slotds of the classes we create.
X  (let* ((meta-braid
X           (iterate ((classd in *meta-braid*))
X             (let* ((name (car classd))
X                    (ds-options (parse-defstruct-options ()
X                             name
X                             (cadr classd)))
X                    (slotds (parse-slot-descriptions ()
X                             ds-options
X                             (caddr classd))))
X               (collect (list name ds-options slotds)))))
X         (all-slots-of-class-class
X           (iterate ((classd in meta-braid))
X             (join (caddr classd)))))
X    (setq *bootstrap-slots* (slots-with-allocation ()
X                                                   all-slots-of-class-class
X                                                   :instance))
X    `(progn
X       (setq *bootstrap-slots* ',*bootstrap-slots*)
X       ;; First make the class class.  It is the class of all the classes in
X       ;; the metabraid so we need it and a wrapper of it so that we can set
X       ;; the wrapped class field of the other metaclasses as we make them.
X       (let* ((class-class
X        (%allocate-class-class ,(length *bootstrap-slots*)))
X              (wrapper-of-class-class (make-class-wrapper class-class)))
X         ,@(iterate ((classd in meta-braid))
X             (collect
X               (destructuring-bind (met-name met-ds-options met-slotds)
X                   classd
X                 (let ((met-includes (ds-options-includes met-ds-options)))
X                   `(let* ((name ',met-name)
X                           (includes ',met-includes)
X                           (ds-options ',met-ds-options)
X                           (slotds ',met-slotds)
X                           (class ,(if (eq met-name 'class)
X                                       'class-class
X                                       `(%allocate-instance--class
X                                          ,(length *bootstrap-slots*)
X                      (class-named 'class))))
X                           (class-wrapper ,(if (eq met-name 'class)
X                                               'wrapper-of-class-class
X                                               '(make-class-wrapper class))))
X                      (setf (iwmc-class-class-wrapper class)
X                wrapper-of-class-class)
X                      (setf (class-named name) class)
X                      (bootstrap-initialize class
X                                            name
X                                            includes
X                                            slotds
X                                            (if (eq class class-class)
X                        class
X                        ())
X                                            class-wrapper
X                                            ds-options))))))
X         (let ((class-cpl (bootstrap-get-slot class-class
X                          'class-precedence-list)))
X           (iterate ((sub in class-cpl)
X                     (sup in (cdr class-cpl)))
X             (push sub (bootstrap-get-slot sup 'direct-subclasses)))))
X       ;; CLASS-INSTANCE-SLOTS has to be defined specially!
X       ;; It cannot be defined in terms of get-slot since it is the method
X       ;; that the get-slot mechanism (actually get-slot-using-class) appeals
X       ;; to to find out what slots are in an instance of a particular class.
X       ;;
X       ;; The fact that class-instance-slots is defined specially this way
X       ;; means that any change to the class class which changes the location
X       ;; of the instance-slots slot must redefine and recompile
X       ;; class-instance-slots.
X       (defun class-instance-slots (class)
X         (get-static-slot--class class
X           ,(%convert-slotd-position-to-slot-index
X              (slotd-position 'instance-slots *bootstrap-slots*))))
X       (defun class-non-instance-slots (class)
X         (get-static-slot--class class
X           ,(%convert-slotd-position-to-slot-index
X              (slotd-position 'non-instance-slots *bootstrap-slots*))))
X       ;; Now define the other accessors and :setf methods for those
X       ;; accessors.
X       ,@(iterate ((classd in meta-braid))
X           (destructuring-bind (name () slotds) classd
X             (join
X               (iterate ((slotd in slotds))
X                 (let* ((slot-name (slotd-name slotd))
X                        (accessor-name (slotd-accessor slotd)))
X                   (unless (memq slot-name '(instance-slots
X                         non-instance-slots))
X                     (collect
X                       `(defmeth ,accessor-name ((,name ,name))
X                          (funcall ,(or (slotd-get-function slotd)
X                    ''get-slot)
X                                   ,name
X                                   ',(slotd-name slotd)))))
X                   (collect
X                     `(defmeth (,accessor-name (:setf (.new_value.)))
X                ((,name ,name))
X                        (funcall ,(or (slotd-put-function slotd) ''put-slot)
X                                 ,name
X                                 ',(slotd-name slotd)
X                                 .new_value.))))))))
X       t)))
X
X
X(eval-when (eval load)
X  (clrhash *class-name-hash-table*)
X  (bootstrap-meta-braid)
X  (recompile-class-of))
X
X(defmeth class-slots ((class class))
X  (append (class-non-instance-slots class)
X      (class-instance-slots class)))
X
X(defmeth (class-direct-methods (:setf (nv))) ((class class))
X  (setf (get-slot class 'direct-methods) nv)
X  (dolist (m nv) (pushnew (method-discriminator m)
X              (get-slot class 'direct-discriminators))))
X
END_OF_FILE
if test 34250 -ne `wc -c <'braid.l'`; then
    echo shar: \"'braid.l'\" unpacked with wrong size!
fi
# end of 'braid.l'
fi
echo shar: End of archive 10 \(of 13\).
cp /dev/null ark10isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 13 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--

Rich $alz            "Anger is an energy"
Cronus Project, BBN Labs    [e-mail]
Moderator, comp.sources.unix    [e-mail]